home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 5 / Amiga Tools 5.iso / tools / developer-tools / andere sprachen / perl5 / perl5.002 / t / lib / safe.t < prev    next >
Encoding:
Text File  |  1996-01-30  |  2.3 KB  |  97 lines
  1. #!./perl
  2.  
  3. BEGIN {
  4.     chdir 't' if -d 't';
  5.     @INC = '../lib';
  6.     require Config; import Config;
  7.     if ($Config{'extensions'} !~ /\bSafe\b/ && $Config{'osname'} ne 'VMS') {
  8.         print "1..0\n";
  9.         exit 0;
  10.     }
  11. }
  12.  
  13. use Safe qw(opname opcode ops_to_mask mask_to_ops);
  14.  
  15. print "1..23\n";
  16.  
  17. # Set up a package namespace of things to be visible to the unsafe code
  18. $Root::foo = "visible";
  19.  
  20. # Stop perl from moaning about identifies which are apparently only used once
  21. $Root::foo .= "";
  22. $bar .= "";
  23.  
  24. $bar = "invisible";
  25. $cpt = new Safe "Root";
  26. $cpt->reval(q{
  27.     system("echo not ok 1");
  28. });
  29. if ($@ =~ /^system trapped by operation mask/) {
  30.     print "ok 1\n";
  31. } else {
  32.     print "not ok 1\n";
  33. }
  34.  
  35. $cpt->reval(q{
  36.     print $foo eq 'visible' ? "ok 2\n" : "not ok 2\n";
  37.     print $main::foo  eq 'visible' ? "ok 3\n" : "not ok 3\n";
  38.     print defined($bar) ? "not ok 4\n" : "ok 4\n";
  39.     print defined($::bar) ? "not ok 5\n" : "ok 5\n";
  40.     print defined($main::bar) ? "not ok 6\n" : "ok 6\n";
  41. });
  42. print $@ ? "not ok 7\n" : "ok 7\n";
  43.  
  44. $foo = "ok 8\n";
  45. %bar = (key => "ok 9\n");
  46. @baz = "o";
  47. push(@baz, "10"); # Two steps to prevent "Identifier used only once..."
  48. $glob = "ok 11\n";
  49. @glob = qw(not ok 16);
  50.  
  51. $" = 'k ';
  52.  
  53. sub sayok12 { print "ok 12\n" }
  54.  
  55. $cpt->share(qw($foo %bar @baz *glob &sayok12 $"));
  56.  
  57. $cpt->reval(q{
  58.     print $foo ? $foo : "not ok 8\n";
  59.     print $bar{key} ? $bar{key} : "not ok 9\n";
  60.     if (@baz) {
  61.     print "@baz\n";
  62.     } else {
  63.     print "not ok 10\n";
  64.     }
  65.     print $glob;
  66.     sayok12();
  67.     $foo =~ s/8/14/;
  68.     $bar{new} = "ok 15\n";
  69.     @glob = qw(ok 16);
  70. });
  71. print $@ ? "not ok 13\n#$@" : "ok 13\n";
  72. $" = ' ';
  73. print $foo, $bar{new}, "@glob\n";
  74.  
  75. $Root::foo = "not ok 17";
  76. @{$cpt->varglob('bar')} = qw(not ok 18);
  77. ${$cpt->varglob('foo')} = "ok 17";
  78. @Root::bar = "ok";
  79. push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..."
  80.  
  81. print "$Root::foo\n";
  82. print "@{$cpt->varglob('bar')}\n";
  83.  
  84. print opname(23) eq "bless" ? "ok 19\n" : "not ok 19\n";
  85. print opcode("bless") == 23 ? "ok 20\n" : "not ok 20\n";
  86.  
  87. $m1 = $cpt->mask();
  88. $cpt->trap("negate");
  89. $m2 = $cpt->mask();
  90. @masked = mask_to_ops($m1);
  91. print $m2 eq ops_to_mask("negate", @masked) ? "ok 21\n" : "not ok 21\n";
  92. $cpt->untrap(187);
  93. substr($m2, 187, 1) = "\0";
  94. print $m2 eq $cpt->mask() ? "ok 22\n" : "not ok 22\n";
  95.  
  96. print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n";
  97.